home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / lib / xm / row-column.d < prev    next >
Encoding:
Text File  |  1992-10-07  |  2.8 KB  |  102 lines
  1. ;;; -*-Scheme-*-
  2.  
  3. (define-widget-type 'rowcolumn "RowColumn.h")
  4.  
  5. (prolog
  6.  
  7. "static SYMDESCR Type_Syms[] = {
  8.    { \"work-area\",        XmWORK_AREA },
  9.    { \"menu-bar\",         XmMENU_BAR },
  10.    { \"menu-pulldown\",    XmMENU_PULLDOWN },
  11.    { \"menu-popup\",       XmMENU_POPUP },
  12.    { \"menu-option\",      XmMENU_OPTION },
  13.    { 0, 0}
  14. };")
  15.  
  16. (define-widget-class 'row-column 'xmRowColumnWidgetClass)
  17.  
  18. (prolog
  19.  
  20. "static void Post_Handler (w, client_data, event, unused) Widget w;
  21.     XtPointer client_data; XEvent *event; Boolean *unused; {
  22.     unsigned int b;
  23.     Arg a;
  24.     XButtonPressedEvent *ep = (XButtonPressedEvent *)event;
  25.     Widget popup = (Widget)client_data;
  26.  
  27.     XtSetArg (a, XmNwhichButton, &b);
  28.     XtGetValues (popup, &a, 1);
  29.     if (ep->button != b)
  30.     return;
  31.     XmMenuPosition (popup, ep);
  32.     XtManageChild (popup);
  33. }")
  34.  
  35. (prolog
  36.  
  37. "static Object Get_Row_Column_CB (p) XmRowColumnCallbackStruct *p; {
  38.     Object ret, s;
  39.     GC_Node2;
  40.  
  41.     ret = s = Make_Widget_Foreign (p->widget);
  42.     GC_Link2 (ret, s);
  43.     ret = Cons (ret, Null);
  44.     s = Get_Any_CB ((XmAnyCallbackStruct *)p);
  45.     ret = Cons (Cdr (s), ret);
  46.     ret = Cons (Car (s), ret);
  47.     GC_Unlink;
  48.     return ret;
  49. }")
  50.  
  51. (define-primitive 'popup-menu-attach-to! '(m w)
  52. "   XtPointer client_data;
  53.     Arg a;
  54.     Check_Widget_Class (m, xmRowColumnWidgetClass);
  55.     Check_Widget (w);
  56.     XtSetArg (a, XmNuserData, &client_data);
  57.     XtGetValues (WIDGET(w)->widget, &a, 1);
  58.     if (client_data)
  59.     XtRemoveEventHandler (WIDGET(w)->widget, ButtonPressMask, 0,
  60.         Post_Handler, client_data);
  61.     client_data = (XtPointer)WIDGET(m)->widget;
  62.     XtAddEventHandler (WIDGET(w)->widget, ButtonPressMask, 0,
  63.     Post_Handler, client_data);
  64.     client_data = (XtPointer)WIDGET(m)->widget;
  65.     XtSetValues (WIDGET(w)->widget, &a, 1);
  66.     return Void;")
  67.  
  68. (define-callback 'row-column 'entryCallback #t)
  69.  
  70. (define row-column-callback->scheme
  71. "   return Get_Row_Column_CB ((XmRowColumnCallbackStruct *)x);")
  72.  
  73. (c->scheme 'row-column-entryCallback row-column-callback->scheme)
  74.  
  75. (define scheme->row-column-type
  76. "   return (XtArgVal)Symbols_To_Bits (x, 0, Type_Syms);")
  77.  
  78. ;;; whichButton resource is declared with a type of XtRWhichButton
  79. ;;; instead of XtRUnsignedInt.  Argh!
  80.  
  81. (define scheme->which-button
  82. "   return (XtArgVal)Get_Integer (x);")
  83.  
  84. (define which-button->scheme
  85. "   return Make_Integer (x);")
  86.  
  87. ;;; entryClass is declared as int!  Bletch!
  88.  
  89. (define scheme->entry-class
  90. "   Check_Type (x, T_Class); return (XtArgVal)CLASS(x)->class;")
  91.  
  92. (define entry-class->scheme
  93. "   return Make_Widget_Class ((WidgetClass)x);")
  94.  
  95. (scheme->c 'row-column-rowColumnType      scheme->row-column-type)
  96.  
  97. (scheme->c 'row-column-whichButton        scheme->which-button)
  98. (c->scheme 'row-column-whichButton        which-button->scheme)
  99.  
  100. (scheme->c 'row-column-entryClass         scheme->entry-class)
  101. (c->scheme 'row-column-entryClass         entry-class->scheme)
  102.